;;; -*- Mode: Lisp; Package: Hacks; Lowercase: Yes; Base: 10 -*-

;;; Dcrock.
;;; Note: This file is in decimal, not octal.

;;; Settable parameters.
(defconst *dc-height* 80)       ; Character height in pixels.
(defconst *dc-width* 60)        ; Character width in pixels.
(defconst *dc-thickness* 6)     ; Character stroke thickness.
(defconst *dc-offset* 10)       ; Slant -- difference in x pos from bottom to top.
(defconst *dc-colon-size* 7)    ; Width and height of colon dots.
(defconst *dc-char-spacing* 25) ; Char-to-char spacing.
(defconst *dc-colon-spacing* 20)        ; Char-to-colon spacing.
(defconst *dc-colon-separation* 20)
(defconst *dc-start-x* 10)      ; Distance from left edge of window to first digit.
(defconst *dc-start-y* 10)      ; Distance from top edge of window to tops of digits.

;;; Derived parameters.
(defconst *dc-total-width*      ; Width of working part of window.
  (+ (* 6 *dc-width*)           ; six digits
     (* 3 *dc-char-spacing*)    ; three char-to-char gaps
     (* 2 *dc-colon-size*)      ; two colons
     (* 4 *dc-colon-spacing*)   ; four char-to-colon gaps
     (* 2 *dc-start-x*)
     *dc-offset*))
(defconst *dc-total-height* (+ *dc-height* (* 2 *dc-start-y*)))
(defconst *dc-half-thickness*
  (truncate *dc-thickness* 2))
(defconst *dc-half-height*
  (truncate *dc-height* 2))
(defconst *dc-slope* (// (small-float *dc-offset*) *dc-height*))

(defconst *dc-whiteness* (make-array '(32 32) ':type 'art-1b))
(dotimes (x 32)
  (dotimes (y 32)
    (aset 0 *dc-whiteness* x y)))

(defconst *dc-x-offsets* (make-array 6))
(loop for form in '((- *dc-start-x* *dc-width*)
                    *dc-char-spacing*
                    (+ *dc-colon-size* (* 2 *dc-colon-spacing*))
                    *dc-char-spacing*
                    (+ *dc-colon-size* (* 2 *dc-colon-spacing*))
                    *dc-char-spacing*)
      for i from 0
      with x = 0 do
      (setq x (+ x *dc-width* (eval form)))
      (aset x *dc-x-offsets* i))

(defmacro draw-stroke (x1-form y1-form width-form height-form array-form)
  `(let* ((y1 (+ base-y ,y1-form))
          (x1 (+ base-x ,x1-form (fix (* (- *dc-height* ,y1-form) *dc-slope*))))
          (x1-offset (+ base-x ,x1-form (fix (* (- *dc-height* (+ ,y1-form ,height-form)) *dc-slope*)))))
     (sys:%draw-triangle
      x1 y1
      x1-offset (+ y1 ,height-form)
      (+ x1-offset ,width-form) (+ y1 ,height-form)
      tv:alu-ior ,array-form)
     (sys:%draw-triangle
      x1 y1
      (+ x1 ,width-form) y1
      (+ x1-offset ,width-form) (+ y1 ,height-form)
      tv:alu-ior ,array-form)))

(defun draw-stroke-one (base-x base-y array)
  (draw-stroke 0
               0
               *dc-width*
               *dc-thickness*
               array))

(defun draw-stroke-two (base-x base-y array)
  (draw-stroke (- *dc-width* *dc-thickness*)
               0
               *dc-thickness*
               (+ *dc-half-height* *dc-half-thickness*)
               array))

(defun draw-stroke-three (base-x base-y array)
  (draw-stroke (- *dc-width* *dc-thickness*)
               (- *dc-half-height* *dc-half-thickness*)
               *dc-thickness*
               (+ *dc-half-height* *dc-half-thickness*)
               array))

(defun draw-stroke-four (base-x base-y array)
  (draw-stroke 0
               (- *dc-height* *dc-thickness*)
               *dc-width*
               *dc-thickness*
               array))

(defun draw-stroke-five (base-x base-y array)
  (draw-stroke 0
               (- *dc-half-height* *dc-half-thickness*)
               *dc-thickness*
               (+ *dc-half-height* *dc-half-thickness*)
               array))

(defun draw-stroke-six (base-x base-y array)
  (draw-stroke 0
               0
               *dc-thickness*
               (+ *dc-half-height* *dc-half-thickness*)
               array))

(defun draw-stroke-seven (base-x base-y array)
  (draw-stroke 0
               (- *dc-half-height* *dc-half-thickness*)
               *dc-width*
               *dc-thickness*
               array))

(defun draw-colon (base-x base-y array)
  (draw-stroke 0
               (+ *dc-half-height* *dc-colon-separation*)
               *dc-colon-size*
               *dc-colon-size*
               array)
  (draw-stroke 0
               (- *dc-half-height* (+ *dc-colon-size* *dc-colon-separation*))
               *dc-colon-size*
               *dc-colon-size*
               array))

(defconst *dc-stroke-list*
           '(draw-stroke-one draw-stroke-two draw-stroke-three draw-stroke-four
             draw-stroke-five draw-stroke-six draw-stroke-seven))

(defconst *dc-digit-array*
          (make-array 10 :initial-contents '((  t   t   t   t   t   t nil)      ;0
                                             (nil   t   t nil nil nil nil)      ;1
                                             (  t   t nil   t   t nil   t)      ;2
                                             (  t   t   t   t nil nil   t)      ;3
                                             (nil   t   t nil nil   t   t)      ;4
                                             (  t nil   t   t nil   t   t)      ;5
                                             (  t nil   t   t   t   t   t)      ;6
                                             (  t   t   t nil nil nil nil)      ;7
                                             (  t   t   t   t   t   t   t)      ;8
                                             (  t   t   t   t nil   t   t)      ;9
                                             )))

(defun draw-digit (digit base-x base-y array)
  (if (not (null digit))
      (loop for on-p in (aref *dc-digit-array* digit)
            for fcn in *dc-stroke-list*
            when on-p do
            (funcall fcn base-x base-y array))))

(defflavor dc-window
  (old-digits new-digits working-array-1 working-array-2 go)
  (tv:process-mixin tv:window)
  (:default-init-plist :process '(dc-top-level)
                       :blinker-p nil :label nil))

(defmethod (dc-window :after :init) (&rest ignore)
  (setq old-digits (make-array 6)
        new-digits (make-array 6)
        working-array-1 (tv:make-sheet-bit-array self (+ *dc-width* *dc-offset*) *dc-height*)
        working-array-2 (tv:make-sheet-bit-array self (+ *dc-width* *dc-offset*) *dc-height*)
        go nil))

(defmacro defun-dc (arglist &body body)
  `(declare-flavor-instance-variables (dc-window)
      (defun ,arglist . ,body)))

(defun-dc change-digit (old-digit new-digit base-x base-y)
  (bitblt tv:alu-seta (+ *dc-width* *dc-offset*) *dc-height*
          *dc-whiteness* 0 0
          working-array-1 0 0)
  (bitblt tv:alu-seta (+ *dc-width* *dc-offset*) *dc-height*
          *dc-whiteness* 0 0
          working-array-2 0 0)
  (draw-digit old-digit 0 0 working-array-1)
  (draw-digit new-digit 0 0 working-array-2)
  (bitblt tv:alu-xor (+ *dc-width* *dc-offset*) *dc-height*
          working-array-1 0 0
          working-array-2 0 0)
  (bitblt tv:alu-xor (+ *dc-width* *dc-offset*) *dc-height*
          working-array-2 0 0
          tv:screen-array base-x base-y))

(defmethod (dc-window :after :refresh) (&optional ignore)
  (cond ((not tv:restored-bits-p)
         (get-new-time)
         (copy-array-contents new-digits old-digits)
         (dotimes (d 6)
           (draw-digit (aref old-digits d) (aref *dc-x-offsets* d) *dc-start-y*
                       tv:screen-array))
         (draw-colon (+ (aref *dc-x-offsets* 1) *dc-width* *dc-colon-spacing*)
                     *dc-start-y* tv:screen-array)
         (draw-colon (+ (aref *dc-x-offsets* 3) *dc-width* *dc-colon-spacing*)
                     *dc-start-y* tv:screen-array))))

(defun-dc update-time ()
  (get-new-time)
  (tv:prepare-sheet (self)
    (dotimes (d 6)
      (let ((old (aref old-digits d))
            (new (aref new-digits d)))
        (if (neq old new)
            (change-digit old new (aref *dc-x-offsets* d) *dc-start-y*)))))
  (copy-array-contents new-digits old-digits))

(defun-dc get-new-time ()
  (multiple-value-bind (sec min hou)
        (time:get-time)
    (and (zerop sec) (zerop (\ min 30.)) (fboundp 'play-time)
         (play-time (if (zerop min) (\ hou 12.) 1)))
    (put-digits hou 0)
    (put-digits min 2)
    (put-digits sec 4)
    (if (zerop (aref new-digits 0))
        (aset nil new-digits 0))))

(defun-dc put-digits (num i)
  (aset (truncate num 10) new-digits i)
  (aset (\ num 10) new-digits (1+ i)))

(defun dc-top-level (window)
  (time:get-time)               ; Make sure timebase initialized
  (funcall window ':top-level))

(defmethod (dc-window :top-level) ()
  (process-wait "go" #'car (locate-in-instance self 'go))
  (loop doing
        (update-time)
        (process-sleep 30.)))

(defvar *dc* nil)

(defun dc (&optional (superior tv:mouse-sheet))
  (if (null *dc*)
      (setq *dc* (tv:make-window 'dc-window
                                 ':superior superior
                                 ':width *dc-total-width*
                                 ':height *dc-total-height*)))
  (multiple-value-bind (w h)
      (funcall superior ':inside-size)
    (funcall *dc* ':center-around (truncate w 2) (truncate h 2)))
  (funcall *dc* ':start)
  (funcall *dc* ':expose))

(defmethod (dc-window :start) ()
  (setq go t))

(compile-flavor-methods dc-window)

(defdemo "Digital Crock" "Standard digital clock" (dc-demo))

(defun dc-demo ()
  (dc)
  (funcall tv:selected-window ':tyi)
  (funcall *dc* ':bury))
